home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD7501772000.psc / Version 1.0 / Matrix1.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2000-07-07  |  8.0 KB  |  227 lines
  1. VERSION 5.00
  2. Begin VB.Form frmScreenSaver 
  3.    BorderStyle     =   0  'None
  4.    ClientHeight    =   5670
  5.    ClientLeft      =   2370
  6.    ClientTop       =   1575
  7.    ClientWidth     =   6585
  8.    ControlBox      =   0   'False
  9.    BeginProperty Font 
  10.       Name            =   "Courier New"
  11.       Size            =   14.25
  12.       Charset         =   0
  13.       Weight          =   400
  14.       Underline       =   0   'False
  15.       Italic          =   0   'False
  16.       Strikethrough   =   0   'False
  17.    EndProperty
  18.    Icon            =   "Matrix1.frx":0000
  19.    KeyPreview      =   -1  'True
  20.    LinkTopic       =   "Form1"
  21.    ScaleHeight     =   378
  22.    ScaleMode       =   3  'Pixel
  23.    ScaleWidth      =   439
  24.    ShowInTaskbar   =   0   'False
  25.    Begin VB.Timer tmrUpdate 
  26.       Interval        =   75
  27.       Left            =   2925
  28.       Top             =   2070
  29.    End
  30. Attribute VB_Name = "frmScreenSaver"
  31. Attribute VB_GlobalNameSpace = False
  32. Attribute VB_Creatable = False
  33. Attribute VB_PredeclaredId = True
  34. Attribute VB_Exposed = False
  35. Option Explicit
  36. DefInt A-Z
  37. Private LastX        As Single
  38. Private LastY        As Single
  39. Private ScrW%, ScrH%
  40. Private TxtHght%, TxtWdth%
  41. Private hMemDc&, hBmp&, hBmpOld&
  42. Private hFont&, hFontOld&
  43. Private MaxHeight
  44. Private MinHeight
  45. Private Type RECT
  46.      rLeft As Long
  47.      rTop As Long
  48.      rRight As Long
  49.      rBottom As Long
  50. End Type
  51. Private Rct As RECT
  52. Private Type StringData
  53.      CurX As Integer
  54.      CurY As Integer
  55.      Dy As Integer
  56.      NumChars As Integer
  57. End Type
  58. Private Mtrx(1 To 100) As StringData   ' One Hundred Output Strings.
  59. Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal x1&, ByVal y1&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
  60. Private Declare Function CreateCompatibleBitmap& Lib "gdi32" (ByVal hDC&, ByVal nWidth&, ByVal nHeight&)
  61. Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hDC&)
  62. Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As Long)
  63. Private Declare Function DeleteDC& Lib "gdi32" (ByVal hDC&)
  64. Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
  65. Private Declare Function FillRect& Lib "user32" (ByVal hDC&, lpRect As RECT, ByVal hBrush&)
  66. Private Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex&)
  67. Private Declare Function SelectObject& Lib "gdi32" (ByVal hDC&, ByVal hObject&)
  68. Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, lParam As Any)
  69. Private Declare Function SetBkMode& Lib "gdi32" (ByVal hDC&, ByVal nBkMode&)
  70. Private Declare Function SetRect& Lib "user32" (lpRect As RECT, ByVal x1&, ByVal y1&, ByVal x2&, ByVal y2&)
  71. Private Declare Function SetTextColor& Lib "gdi32" (ByVal hDC&, ByVal crColor&)
  72. Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hDC&, ByVal x1&, ByVal y1&, ByVal lpString$, ByVal nCount&)
  73. Private Const TRANSPARENT = 1
  74. Private Const WM_GETFONT = &H31
  75. '--------------------------------------------------
  76. 'Name        : UpdateFont
  77. 'Created     : 07/07/2000 08:07
  78. '--------------------------------------------------
  79. 'Author      : Richard James Moss
  80. 'Organisation: Ariad Software
  81. '--------------------------------------------------
  82. 'Description : Updates the font of the back buffer
  83. '--------------------------------------------------
  84. 'Updates     :
  85. '--------------------------------------------------
  86. '          Ariad Procedure Builder Add-In 1.00.0036
  87. Public Sub UpdateFont()
  88. Attribute UpdateFont.VB_Description = "Updates the font of the back buffer"
  89.  '##BD Updates the font of the back buffer
  90.  If hFontOld Then
  91.   DeleteObject SelectObject(hMemDc, hFontOld)
  92.  End If
  93.  ' Get The Form's Font (Courier, Regular, 15)... (Just Call Me Spock!).
  94.  hFont = SendMessage(hWnd, WM_GETFONT, 0, 0&)
  95.  ' Select It Into Our Back Buffer So We Can Output Text.
  96.  hFontOld = SelectObject(hMemDc, hFont)
  97. End Sub '(Public) Sub UpdateFont ()
  98. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  99.  Form_KeyPress KeyCode
  100. End Sub
  101. Private Sub Form_KeyPress(KeyAscii As Integer)
  102.  If PreviewMode = 0 Then
  103.   Unload Me
  104.  End If
  105. End Sub
  106. Private Sub Form_Load()
  107.  Dim Cols
  108.  Dim K
  109.  'setup values
  110.  BackColor = BackgroundClr
  111.  tmrUpdate.Interval = Speed
  112.  Set Font = StringToFont(FontData$)
  113.  'now screensaver
  114.     ' Aquire The Screen Width And Height In Pixels.
  115.     ScrW = GetSystemMetrics(0)
  116.     ScrH = GetSystemMetrics(1)
  117.     ' Setup A RECT Structure The Size Of The Screen.
  118.     ' This Will Be Used Later With The API Function "FillRect"
  119.     ' To Clear The Back Buffer.
  120.     SetRect Rct, 0, 0, ScrW, ScrH
  121.     ' Create An Off Screen Drawing Area In Memory (Back Buffer)... (Backbuffer,.. That Picture NoOne Can See).
  122.     hMemDc = CreateCompatibleDC(0)
  123.     hBmp = CreateCompatibleBitmap(hDC, ScrW, ScrH)
  124.     hBmpOld = SelectObject(hMemDc, hBmp)
  125.     SetBkMode hMemDc, TRANSPARENT
  126.     UpdateFont
  127.     TxtWdth = TextWidth("A")
  128.     TxtHght = TextHeight("A")
  129.     MaxHeight = ScrH - TxtHght
  130.     ' Seed Random Number Generator.
  131.     Randomize
  132.     For K = 1 To 100
  133.      Cols = Int(ScrW / TxtWdth)
  134.         Mtrx(K).CurX = Int(Rnd * Cols) * TxtWdth 'Rnd * (ScrW - TxtWdth)
  135.         Mtrx(K).NumChars = Int((20 - 5 + 1) * Rnd + 5)
  136.         Mtrx(K).Dy = TxtHght + Rnd * TxtHght
  137.         MinHeight = -2 * Mtrx(K).Dy * Mtrx(K).NumChars
  138.         Mtrx(K).CurY = Int((MaxHeight - MinHeight + 1) * Rnd + MinHeight)
  139.     Next 'showtime...
  140.  If PreviewMode = 0 Then
  141.   ScreenSaverActive = -1
  142.   WindowState = 2
  143.   CursorVisible = 0
  144.   Show
  145.  End If
  146. End Sub
  147. Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  148.  If PreviewMode = 0 Then
  149. '  Unload Me
  150.  End If
  151. End Sub
  152. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  153.  If PreviewMode = 0 Then
  154.   If (LastX = 0 And LastY = 0) Or (Abs(LastX - X) < 2 And Abs(LastY - Y) < 2) Then
  155.    ' Small Mouse Movement...
  156.    LastX = X
  157.    LastY = Y
  158.   Else
  159.    ' Massive Mouse-Movement (Rat'ssssssssss)... End.
  160.    Unload Me
  161.   End If
  162.  End If
  163. End Sub
  164. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  165.  ' Delete The Font We Created.
  166.  DeleteObject SelectObject(hMemDc, hFontOld)
  167.  ' Delete The Back Buffer.
  168.  DeleteObject SelectObject(hMemDc, hBmpOld)
  169.  DeleteDC hMemDc
  170.  CursorVisible = -1
  171.  ScreenSaverActive = 0
  172. End Sub
  173. Private Sub tmrUpdate_Timer()
  174.  Dim hBrush As Long
  175.  Dim Char$
  176.  Dim Cols
  177.  Dim K, N
  178.  Dim CY
  179.  Dim MX
  180.  ' Clear The BackBuffer.
  181.  hBrush = CreateSolidBrush(BackgroundClr)
  182.  FillRect hMemDc, Rct, hBrush
  183.  DeleteObject hBrush
  184.  ' Output Our Strings.
  185.  For K = 1 To 100
  186.   CY = Mtrx(K).CurY
  187.   MX = Mtrx(K).NumChars
  188.   For N = 1 To MX
  189.    If N = MX Then ' Last Char In String.
  190.     SetTextColor hMemDc, HighlightTextClr  ' The Brightest Letter.
  191.    Else
  192.     SetTextColor hMemDc, DimmedTextClr   ' The Darker Letters.
  193.    End If
  194.    ' OutPut The Character On The Back Buffer.
  195.    Select Case CharacterSet
  196.     Case 0           'complete
  197.      Char$ = Chr$(Int((255 - 33 + 1) * Rnd + 33))
  198.     Case 1           'binary
  199.      Char$ = Chr$((Rnd * 1) + 48)
  200.     Case Else        'custom
  201.      If Len(CharacterSetChar) Then
  202.       Char$ = Mid$(CharacterSetChar, Int(Rnd * (Len(CharacterSetChar & " ") - 1) + 1), 1)
  203.      Else
  204.       Char$ = Chr$((Rnd * 1) + 48)
  205.      End If
  206.    End Select
  207.    TextOut hMemDc, Mtrx(K).CurX, CY, Char$, 1
  208.    'End If
  209.    CY = CY + Mtrx(K).Dy
  210.   Next
  211.   Mtrx(K).CurY = Mtrx(K).CurY + Mtrx(K).Dy
  212.   If Mtrx(K).CurY > ScrH Then
  213.    ' A String Has Now Left The Screen So
  214.    ' Need To Initialize Another One.
  215.    Cols = Int(ScrW / TxtWdth)
  216.    Mtrx(K).CurX = Int(Rnd * Cols) * TxtWdth 'Rnd * (ScrW - TxtWdth)
  217. '    Mtrx(K).CurX = Rnd * (ScrW - TxtWdth)
  218.    Mtrx(K).NumChars = Int((20 - 5 + 1) * Rnd + 5)
  219.    Mtrx(K).Dy = TxtHght + Rnd * (TxtHght \ 2)
  220.    Mtrx(K).CurY = -2 * Mtrx(K).Dy * Mtrx(K).NumChars
  221.   End If
  222.  Next
  223.  ' Now That The Off Screen Drawing Is Complete,
  224.  ' Blit The Finished Frame Onto The Screen.
  225.  BitBlt hDC, 0, 0, ScrW, ScrH, hMemDc, 0, 0, vbSrcCopy
  226. End Sub
  227.